home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM A / PD-ROM A.iso / Programming / Programming Languages / Pocket Forth rel.5 / Source code / Common.txt < prev    next >
Encoding:
Text File  |  1991-08-04  |  33.3 KB  |  1,348 lines  |  [TEXT/EDIT]
  1. ; this file is: Common.txt  --  forth words
  2. ; Tue Apr 05, 1988 21:59:10 load files >32K
  3. ; Thu Apr 07, 1988 15:59:46 nested loads
  4. ; Tue Apr 19, 1988 05:05:37 change "?button"
  5. ; Mon Apr 25, 1988 15:10:19 implement macros
  6. ; Tue Apr 26, 1988 19:49:49 optomizing "back"
  7. ; Thu Apr 28, 1988 23:09:23 fix id.  better constant,2constant  add zero
  8. ; Fri Apr 29, 1988 09:43:49 add dliteral
  9. ; Sun May 01, 1988 04:24:52 make variable a macro
  10. ; Thu May 12, 1988 11:41:08 remove (pdo)  add 1- 2- & sp@  use slashFail
  11. ; Sun May 29, 1988 20:16:39 make create shorter
  12. ; Tue May 31, 1988 14:27:25 make +md a 4 byte macro  remove 2-
  13. ; Tue Jun 07, 1988 11:39:00 add r0@, s0@, rp@  redo stod
  14. ; Sun Jun 23, 1991 09:33:00 add open
  15.  
  16.     DC.B    6,'?ST'            ; "?stack" ( ? -- )
  17.     DC.W    key-theLink
  18. StkChk:    CMPA.L    UFlow-base(BP),PS
  19.     BPL.S    @0
  20.     RTS
  21.     @0:    JSR    space-base(BP)
  22.       MOVEQ    #42,D0            ; print *  if stack underflow
  23.     JSR    EmitCode-base(BP)
  24.     BRA.S    huh
  25.  
  26.     DC.B    6,'WHA'            ; "whazat" ( -- )
  27.     DC.W    stkchk-theLink
  28. WhaZat:    JSR    here-base(BP)        ; push token address
  29.     JSR    count-base(BP)
  30.     JSR    type-base(BP)        ; type unknown token
  31.     JSR    space-base(BP)
  32.     BRA.S    huh
  33.     
  34.     DC.B    5,'ABO'            ; "abort" ( -- )
  35.     DC.W    whazat-theLink
  36. huh:    MOVEQ    #63,D0            ; send ?  means not found in dict
  37.     JSR    EmitCode-base(BP)
  38.     JSR    doCR-base(BP)
  39.     BRA.S    fin
  40.     
  41.     DC.B    4,'QUI'            ; "quit" ( -- )
  42.     DC.W    huh-theLink        ;    clear stacks and restart
  43. fin:    JSR    emptyfs-base(BP)    ; clear pending loads
  44.     MOVE.L    Szero-base(BP),PS    ; reset stack pointer
  45.     CLR.L    fcolon-base(BP)        ; initialize flags
  46.     BSET.B    #7,fint-base(BP)
  47.     JMP    nret-base(BP)
  48.  
  49.     DC.B    2,'CR',0        ; "cr" ( -- ) output CR to screen
  50.     DC.W    fin-theLink
  51. CRLF:    JMP    doCR-Base(BP)
  52.  
  53.     DC.B    3,'.OK'            ; ".ok" ( -- )
  54.     DC.W    crlf-theLink
  55. Prompt:    JSR    space-base(BP)        ; send space
  56.     MOVEQ    #111,D0
  57.     JSR    EmitCode-base(BP)    ; send "o"
  58.     MOVEQ    #107,D0
  59.     JSR    EmitCode-base(BP)    ; send "k"
  60.     JMP    space-base(BP)        ; send another space & return
  61.  
  62.     DC.B    5,'UPP'            ; "upper" ( addr -- )
  63.     DC.W    prompt-theLink        ;   change a string to upper case
  64. Upper:    MOVE    (PS)+,D0
  65.     LEA    0(BP,D0.W),A0        ; get the address
  66.     CLR    D0
  67.     MOVE.B    (A0),D0            ; get count
  68.     @0:    CMPI.B    #$60,0(A0,D0.W)        ; BEGIN  get char at addr + count
  69.         BLE.S    @1            ;   char > 'a'
  70.     CMPI.B    #$7B,0(A0,D0.W)        ;   char < 'z'
  71.     BGE.S    @1            ;   AND IF
  72.     SUBI.B    #32,0(A0,D0.W)        ;     char 32 - -> char THEN
  73.     @1:    DBRA    D0,@0            ; count 1- -> count count NOT UNTIL
  74.     RTS
  75.  
  76.     DC.B    5,'TOK'            ; "token" ( -- ) put a token
  77.     DC.W    upper-theLink        ;   from (IS) into (DP),
  78. Token:    MOVE    #32,-(PS)        ;   which is at end of dict.
  79.     BSR.S    word
  80.     JSR    here-base(BP)        ; Fri Apr 29, 1988 00:27:23 simpl
  81.     BRA.S    Upper
  82.     
  83.     DC.B    6,'HEA'            ; "header" ( -- ) create a header
  84.     DC.W    token-theLink        ;   for the current word at DP
  85. Header:    MOVE    Dict,4(DP)        ; link header to dictionary
  86.     MOVE.L    DP,Dict            ; update DICT
  87.     SUB.L    BP,Dict            ; make it a rel.addr
  88.     LEA    6(DP),DP        ; update DP
  89.     RTS
  90.  
  91.     DC.B    4,'WOR'            ; "word" ( c -- ) c is delimiter
  92.     DC.W    header-theLink        ;   get chars from (IS) into HERE
  93. Word:    MOVE.L    D4,-(SP)        ; preserve the register
  94.     MOVE    (PS)+,D4        ; get delimiter character
  95.     CLR.L    (DP)            ; clear token buffer
  96.     CLR.L    D1            ; clear count
  97.     @0:    MOVE.B    (IS)+,D0        ; getcharacter until delimiter
  98.     CMP.B    D4,D0
  99.     BEQ.S    @1
  100.     MOVE.B    D0,1(DP,D1)        ; place in token buffer
  101.     ADDQ.B    #1,D1            ; increment count
  102.     BRA.S    @0
  103.     @1:    MOVE.B    D1,(DP)            ; put count in 1st byte of buffer
  104.     BEQ.S    @0            ; if count is 0 repeat
  105.     MOVE.L    (SP)+,D4        ; restore the register
  106.     RTS
  107.  
  108.     DC.B    6,'SEA'            ; "search" ( addr -- cfa t  OR  f )
  109.     DC.W    word-theLink
  110. Search:    MOVE.L    (DP),D1            ; put token "stem" in D1
  111.     MOVE    (PS),D0            ; use A0 as search pointer
  112.     CLR    fmacro-base(BP)        ; clear the macro flag
  113.     @0:    LEA    0(BP,D0.W),A0        ; DO
  114.     TST    (A0)            ;   IF DictStart  exit NOFIND
  115.     BEQ.S    nofind
  116.     CMP.L    (A0),D1            ;   compare word to candidate
  117.     BEQ.S    find            ;   IF found, exit FIND
  118.     BCHG    #31,D1            ;   set precedence bit
  119.     CMP.L    (A0),D1            ;   compare to "immediate" version
  120.     BEQ.S    ifind            ;   IF found, exit FINDIMM
  121.     BCHG    #31,D1            ;   reset precedence bit
  122.     BCHG    #30,D1            ;   set precedence bit
  123.     CMP.L    (A0),D1            ;   compare to "immediate" version
  124.     BEQ.S    mfind            ;   IF found, exit FINDIMM
  125.     BCHG    #30,D1            ;   reset precedence bit
  126.     MOVE    4(A0),D0        ;   get link rel.address
  127.     BRA.S    @0            ; LOOP
  128. nofind:    CLR    (PS)            ; push fail flag
  129.     RTS
  130.  mfind:    BSET.B    #7,fmacro-base(BP)    ; set macro flag
  131.     BRA.S    find
  132.  ifind:    BSET.B    #7,fimmed-base(BP)    ; set immediate flag
  133.   find:    LEA    6(A0),A0        ; cfa is at 6+nfa
  134.     SUBA.L    BP,A0            ; convert code address to relative
  135.     MOVE    A0,(PS)            ; push code rel address
  136.     MOVE    #-1,-(PS)        ; push success flag
  137.     RTS
  138.  
  139.     DC.B    6,'NUM'            ; "number" ( addr -- n t  OR  f )
  140.     DC.W    search-theLink
  141. Number:    MOVE.L    D4,-(SP)        ; save the register
  142.     CLR.L    D1
  143.     CLR.L    D4            ; clear conversion register
  144.     MOVE    (PS)+,D0        ; get token addr in A0
  145.     LEA    0(BP,D0.W),A0        ; put abs.addr in A0
  146.     CMPI.B    #'-',1(A0)        ; is it negative?
  147.     BNE.S    @0            ; IF yes
  148.     BSET.B    #7,fneg-base(BP)    ;     set negative flag
  149.     MOVE.B    #'0',1(A0)        ;     change dash to zero
  150.     @0:    CLR.L    D0            ; THEN
  151.     MOVE.B    (A0)+,D1        ; get digit count
  152.  digit:    MOVE.B    (A0)+,D0        ; BEGIN get next digit
  153.     SUBI.B    #48,D0            ;     strip ASCII prefix
  154.     BLT.S    @2            ;     if digit too small, FAIL
  155.     CMP    #10,D0            ;     if digit > 9
  156.     BLT.S    @1            ;     adjust for radix>10 values
  157.     SUBI.B    #7,D0            ;     and test again
  158.     CMP    #10,D0
  159.     BLT.S    @2
  160.     @1:    CMP    NBase-base(BP),D0    ;     if base < digit
  161.     BGE.S    @2            ;     FAIL
  162.     MULU    NBase-base(BP),D4    ;     multiply value by base
  163.     ADD    D0,D4            ;     add current digit
  164.     SUBQ.B    #1,D1            ;     decrement count
  165.     BNE.S    digit            ; UNTIL no digits remain
  166.         BCLR    #7,fneg-base(BP)    ; test and clear negative flag
  167.     BEQ.S    @0            ; if set
  168.     NEG    D4            ; Negate it
  169.     @0:    MOVE    D4,-(PS)        ; push number
  170.     MOVE    #-1,-(PS)        ; push success flag
  171.     BRA.S    @3
  172.     @2:    CLR    -(PS)            ; push fail flag
  173.     @3:    MOVE.L    (SP)+,D4        ; restore the register
  174.     RTS
  175.  
  176.     DC.B    7,'EXE'            ; "execute" ( cfa -- ) do a routine
  177.     DC.W    number-theLink        ;    whose cfa is on the stack
  178. EXECUTE    MOVE    (PS)+,D0        ; pop code address
  179.     JMP    0(BP,D0.W)        ; execute & return
  180.  
  181.     DC.B    8,'MCO'            ; "mcompile" ( cfa -- ) 
  182.     DC.W    Execute-theLink        ; compile subroutine bodies inline 
  183. MComp:    MOVE    (PS)+,D0
  184.     LEA    0(BP,D0.W),A0        ; addr of word
  185.     @0:    MOVE    (A0)+,D0
  186.     CMPI    #$4E75,D0        ; if its an RTS your done
  187.     BEQ.S    @1
  188.     MOVE    D0,(A2)+        ; if not, compile it
  189.     BRA.S    @0            ; do next word
  190.     @1:    RTS
  191.     
  192.     DC.B    7,'COM'            ; "compile" ( cfa -- ) compile a 
  193.     DC.W    mcomp-theLink        ;    call to the cfa on the stack
  194. COMPILE    MOVE    #$04EAB,(DP)+        ; compile "JSR d(A3)"
  195.     BRA.S    Comma            ; compile displacement value
  196.  
  197.     DC.B    9,'IMM'            ; "immediate" ( -- ) make the last
  198.     DC.W    compile-theLink        ;   word defined immediate
  199. IMMED    LEA    0(BP,Dict.W),A0        ; get address of most recent word
  200.     BSET    #7,(A0)            ; set precedence bit
  201.     RTS
  202.  
  203.     DC.B    5,'MAC'            ; "macro" ( -- ) make the last
  204.     DC.W    immed-theLink        ;   word defined an inline macro
  205. marco:    LEA    0(BP,Dict.W),A0        ; get address of most recent word
  206.     BSET    #6,(A0)            ; set macro bit
  207.     RTS
  208.  
  209.     DC.B    1,':',0,0        ; ":" ( -- ) make a header for a 
  210.     DC.W    marco-theLink        ;   word definition
  211. COLON    JSR    token-Base(BP)        ; make header
  212.     JSR    header-base(BP)
  213.     BRA.S    rbrack            ; enter compile mode
  214.     
  215.     DC.B    129,']',0,0        ; "]" ( -- ) enter compile mode
  216.     DC.W    colon-theLink
  217. rBrack:    BSET    #7,fcolon-base(BP)    ; set colon flag
  218.     RTS
  219.  
  220.     DC.B    129,';',0,0        ; ";" ( -- ) end a word definition
  221.     DC.W    rBrack-theLink
  222. SEMI    MOVE    #$04E75,(DP)+        ; compile "RTS"
  223.     BRA.S    lbrack
  224.     
  225.     DC.B    129,'[',0,0        ; "[" ( -- ) leave compile mode
  226.     DC.W    semi-theLink
  227. lBrack:    CLR.B    fcolon-base(BP)        ; clear colon flag
  228.     RTS
  229.     
  230.     DC.B    7,'LIT'            ; "literal" compiling: ( n -- )
  231.     DC.W    lBrack-theLink        ;   executing: ( -- n )
  232. LITERAL    MOVE    #$03D3C,(DP)+        ; compile move #xxxx,-(PS)
  233.     BRA.S    Comma            ; compile constant
  234.  
  235.     DC.B    64+1,',',0,0        ; "," ( n -- )
  236.     DC.W    literal-theLink
  237. COMMA    MOVE    (PS)+,(DP)+        ; pop number to dictionary
  238.     RTS
  239.  
  240.     DC.B    8,'DLI'            ; "literal" compiling: ( d -- )
  241.     DC.W    comma-theLink        ;   executing: ( -- d )
  242. DLit:    MOVE    #$2D3C,(DP)+        ; compile move.l #xxxx,-(PS)
  243.     MOVE.L    (PS)+,(DP)+        ; compile double number
  244.     RTS
  245.  
  246.     DC.B    4,'>RE'            ; ">rel" (to-rel) ( rel.uu) (rel.ah)
  247.     DC.W    dlit-theLink        ; ( daddr32 -- addr16 )
  248. toRel:    MOVE.L    (PS)+,D0        ; get the Daddr32 from stack
  249.     SUB.L    BP,D0            ; get difference from base addr
  250.     MOVE    D0,-(PS)        ; push the 16 bit part of it
  251.     RTS
  252.  
  253.     DC.B    5,'SPA'            ; "space" ( -- ) emit a space
  254.     DC.W    torel-theLink
  255. space:    MOVE.L    #32,D0
  256.     JMP    EmitCode-Base(BP)
  257.     
  258.     DC.B    4,'TYP'            ; "type" ( rel.addr len -- )
  259.     DC.W    space-theLink        ;  emit len characters from rel.addr
  260. Type:    MOVEM.L    D3/D4,-(SP)        ; don't trash registers!
  261.     MOVE    (PS)+,D3        ; get character count
  262.     SUBQ.B    #1,D3
  263.     MOVE    (PS)+,D4        ; get string relative address
  264.     @0:    MOVE.B    0(BP,D4.W),D0        ; get character byte
  265.     JSR    EmitCode-Base(BP)    ; print character byte
  266.     ADDQ    #1,D4
  267.     DBRA    D3,@0
  268.     MOVEM.L    (SP)+,D3/D4        ; restore registers
  269.     BRA.S    space
  270.  
  271.     DC.B    64+3,'+MD'        ; "+MD" ( offset -- addr )
  272.     DC.W    type-theLink
  273. MacDat:    ADDI    #theWindow-base,(PS)    ; add data addr to stacked offset
  274.     RTS
  275.     
  276.     DC.B    4,'PAG'            ; "page" ( -- )
  277.     DC.W    macdat-theLink        ; clear the window
  278. Page:    PEA    WContRect-base(BP)    ; The visable part of the window.
  279.     _EraseRect
  280.     MOVE    #1,-(SP)
  281.     MOVE    #9,-(SP)
  282.     _MoveTo                ; set pen position to home (1,9)
  283.     JMP    TextNormal-base(BP)
  284.  
  285.     DC.B    4,'BEE'            ; "beep" ( -- )
  286.     DC.W    page-theLink
  287. Beep:    MOVE.W    #3,-(SP)
  288.     _SysBeep
  289.     RTS
  290.  
  291.     DC.B    64+3,'MON'        ; "mon" ( -- ) execute _Debugger
  292.     DC.W    beep-theLink
  293. Mon:    _DeBugger
  294.     RTS
  295.  
  296. TexD:    DC.W    'TEXT'
  297.  
  298.     DC.B    4,'OPE'        ; "open" ( -- )
  299.     DC.W    mon-theLink
  300. Open:    MOVE.L    #$4B0037,-(SP)        ; point: 75,55
  301.     CLR.L    -(SP)            ; no prompt
  302.     CLR.L    -(SP)            ; no filter
  303.     MOVE    #1,-(SP)        ; 1 type
  304.     PEA    texd-base(BP)
  305.     CLR.L    -(SP)            ; no hook
  306.     PEA    (A2)            ; put sfreply at here
  307.     MOVE    #2,-(SP)
  308.     _Pack3
  309.     TST    (A2)            ; check 'good' field
  310.     BEQ.S    beep            ; beep if cancel
  311.  
  312.     MOVE    6(A2),-(PS)        ; hold the vrefnum on stack
  313.     CLR    D0
  314.     @0:    MOVE.L    10(A2,D0.W),0(A2,D0.W)    ; move the file name to 'here'
  315.     ADDQ    #4,D0
  316.     CMP    #32,D0
  317.     BLE.S    @0
  318.     BRA.S    load1
  319.     
  320.     DC.B    3,'-->'            ; "-->" ( -- )
  321.     DC.W    open-theLink
  322. Load:    JSR    token-base(BP)        ; put filename string at here
  323.     CLR    -(PS)            ; set vrefnum to 0 (path is specified)
  324.  load1:    MOVE    fsptr-base(BP),D0    ; get file stack pointer
  325.     BMI    @0            ;  ... save the offset into text ...
  326.     LEA    fofsets-base(BP),A0    ;  ... at fofsets+fspointer
  327.     MOVE.L    TextO-base(BP),0(A0,D0)
  328.     LEA    fends-base(BP),A0    ;  TextE at fends+fspointer
  329.     MOVE.L    TextE-base(BP),0(A0,D0)
  330.     @0:    ADDQ    #4,fsptr-base(BP)    ; increment the file stack pointer
  331.     
  332.     MOVE.L    #80,D0            ; create an 80 byte block for
  333.     DC.W    $A31E    ; _NewPtr ,CLEAR - the file control buffer
  334.     MOVE.L    A0,A4            ; save it for later
  335.     MOVE.B    #1,27(A0)        ; set read only permission
  336.     MOVE.L    DP,18(A0)        ; set name pointer
  337.     MOVE    (PS)+,22(A0)        ; set vrefnum (working directory)
  338.     DC.W    $A100    ; _HOpen the file
  339.     TST    16(A0)
  340.     BNE.S    derror
  341.     _GetEOF                ; get ...
  342.     MOVE.L    28(A0),36(A0)        ;  ... and set ...
  343.     MOVE.L    28(A0),-(PS)        ;  ... and hold the file size
  344.     
  345.     MOVE.L    (PS),D0            ; set block size = file size
  346.     _NewHandle
  347.     BMI.S    derror
  348.     
  349.     MOVE    fsptr-base(BP),D0    ; get file stack pointer
  350.     LEA    fstack-base(BP),A1    ; file stack address
  351.     MOVE.L    A0,0(A1,D0.W)        ; stash the handle at fstack+(fsptr)
  352.     _HLock
  353.     
  354.     MOVE.L    (A0),A0            ; get start addr of block
  355.     MOVE.L    A0,TextO-base(BP)    ; set buffer start
  356.     MOVE.L    A0,D0            ; set buffer end ...
  357.     ADD.L    (PS)+,D0
  358.     MOVE.L    D0,TextE-base(BP)    ;  ... to start + size
  359.     
  360.     MOVE.L    A4,A0
  361.     MOVE.L    TextO-base(BP),32(A0)    ; set read buffer addr in fcb
  362.     _Read                ; read data from file ...
  363.     TST    16(A0)            ; ... to scrap buffer
  364.     BNE    derror
  365.     _Close
  366.     _DisposPtr
  367.     JMP    go-base(BP)        ; interpret scrap buffer
  368.  
  369. DError:    MOVE    16(A0),-(PS)
  370.     _Close
  371.     _DisposPtr
  372.     JSR    pquote-base(BP)
  373.     DC.B    10,'I/O Error:',0    ; print the error messsage
  374.     JSR    dot-base(BP)        ; report the error number
  375.     JMP    huh-base(BP)
  376.     
  377. GRet:    LEA    Bottom,BP        ; reset the base pointer
  378.       LEA    0(BP,D1.W),DP        ; abs.addr into register
  379.     LEA    0(BP,D2.W),IS
  380.     JSR    toabs-base(BP)
  381.     MOVE.L    (PS)+,(RS)
  382.     RTS
  383.  
  384.     DC.B    4,'GRO'            ; "grow" ( bytes -- )
  385.     DC.W    load-theLink        ; enlarge the dictionary headroom
  386. Grow:    JSR    here-base(BP)
  387.     MOVE    (PS)+,D1        ; hold rel DP in D1
  388.     MOVE.L    IS,-(PS)
  389.     JSR    torel-base(BP)
  390.     MOVE    (PS)+,D2
  391.     MOVE.L    (RS),-(PS)
  392.     JSR    torel-base(BP)
  393.     JSR    swapp-base(BP)
  394.     MOVEA.L    expand-base(BP),A0
  395.     JMP    (A0)            ; JSR won't return here
  396.  
  397.     DC.B    4,'ROO'            ; "room" ( -- bytes )
  398.     DC.W    grow-theLink
  399. Room:    LEA    Bottom,A0        ; version 3+ use (PC) addressing
  400.     _RecoverHandle            ; use handle rather than pointer
  401.     _GetHandleSize
  402.     LEA    Bottom,A0        ; Bottom ... version 3+ use (PC) addressing
  403.     ADDA.L    D0,A0            ;  +  block size ...
  404.     SUBA.L    A2,A0            ;  -  end of dictionary
  405.     MOVE    A0,-(PS)        ;  =  unused dictionary space
  406.     RTS
  407.     
  408.     DC.B    4,'SAV'            ; "save" ( -- ) save the dictionary
  409.     DC.W    room-theLink
  410. Save:    JSR    here-base(BP)
  411.     MOVE    (PS)+,freePt-base(BP)    ; save current DP
  412.     MOVE    Dict,DictPt-base(BP)    ; save current DictPt
  413.     BSR.S    room
  414.     MOVE    (PS),freesz-base(BP)    ; save current headroom
  415.     JSR    negate-base(BP)
  416.     BSR.S    grow            ; reduce headroom to 4 bytes
  417.     LEA    Bottom,A0        ; version 3+ use (PC) addressing
  418.     _RecoverHandle            ; get DICT's handle
  419.     CLR    -(SP)
  420.     MOVE.L    A0,-(SP)        ; push 2, 1 for each operation
  421.     MOVE.L    A0,-(SP)
  422.     _ChangedResource
  423.     _HomeResFile
  424.     _UpdateResFile            ; write out the DICT
  425.     MOVE    freesz-base(BP),-(PS)
  426.     BRA.S    grow            ; restore headroom
  427.  
  428.     DC.B    4,'NUL'            ; "null" ( -- )
  429.     DC.W    save-theLink
  430. Null:    RTS
  431.     
  432.     DC.B    8,'CON'            ; "constant" compile: ( n16 -- )
  433.     DC.W    null-theLink        ;            runtime: ( -- n16 )
  434. Const:    JSR    token-base(BP)        ; make a header for the next token
  435.     JSR    header-base(BP)
  436.     JSR    marco-base(BP)        ; to return a constant
  437.     JSR    literal-base(BP)    ; compile time comma, runtime push
  438.     MOVE    #$4E75,(DP)+        ; compile  rts 
  439.     RTS
  440.  
  441.     DC.B    6,'CRE'            ; "create" compile: ( -- ) 
  442.     DC.W    const-theLink        ;          runtime: ( -- addr16 )
  443. Create:    JSR    token-base(BP)        ; give token this runtime action:
  444.     JSR    header-base(BP)
  445.     MOVE    #$3D3C,(DP)+        ;  • move     #nnnn,-(ps)
  446.     JSR    here-base(BP)
  447.     ADDQ    #6,(PS)
  448.     MOVE    (PS)+,(DP)+        ; supply the nnnn from above
  449.     MOVE    #$4EEB,(DP)+        ;  • jmp     null-base(bp)
  450.     MOVE.L    DP,DoesAddr-base(BP)    ; set DoesAddr to this "null"
  451.     MOVE    #null-base,(DP)+
  452.     RTS
  453.  
  454.     DC.B    5,'DOE'            ; "does>" ( -- ) (use after create)
  455.     DC.W    create-theLink        ;   set runtime action 
  456. Does:    MOVE.L    (RS)+,D0        ; pop the return address
  457.     SUB.L    BP,D0            ; convert to rel.addr
  458.     MOVE.L    DoesAddr-base(BP),A0    ; load jmp d(bp) address from create
  459.     MOVE    D0,(A0)            ; and stash rel.addr into it
  460.     RTS                ; returns same as ;
  461.  
  462.     DC.B    5,'ALL'            ; "allot" ( n16 -- )
  463.     DC.W    does-theLink        ;  compiles nada into the dictionary
  464. Allot:    ADDQ    #1,(PS)
  465.     ANDI    #$FFFE,(PS)        ; make it even!
  466.     ADDA    (PS)+,DP        ; increment the dictionary pointer
  467.     RTS
  468.  
  469.     DC.B    8,'VAR'            ; "variable" compile: ( -- )
  470.     DC.W    allot-theLink        ;            runtime: ( -- addr16 )
  471. Variable:
  472.     JSR    token-base(BP)        ; give token this runtime action:
  473.     JSR    header-base(BP)
  474.     JSR    marco-base(BP)        ; Sun May 1, 1988 04:24:44
  475.     MOVE    #$3D3C,(DP)+        ;  • move   #nnnn,-(ps)
  476.     JSR    here-base(BP)
  477.     ADDQ    #4,(PS)            ;    calculate nnnn
  478.     MOVE    (PS)+,(DP)+        ;  • (this is the nnnn)
  479.     MOVE    #$4E75,(DP)+        ;  • rts
  480.     ADDQ.L    #2,DP            ; 2 allot
  481.     RTS
  482.  
  483.     DC.B    4,'EMI'            ; "emit" ( n -- ) send the ascii
  484.     DC.W    variable-theLink    ;  to the terminal
  485. Emit:    MOVE    (PS)+,D0
  486.     JMP    EmitCode-base(BP)
  487.  
  488.     DC.B    6,'EXP'            ; "expect" ( addr count -- )
  489.     DC.W    emit-theLink
  490. Expect:    JMP    Xpect-base(BP)
  491.  
  492.     DC.B    64+5,'>NA'        ; ">name" ( 'addr -- name.addr )
  493.     DC.W    expect-theLink
  494. toname:    SUBQ    #6,(PS)
  495.     RTS
  496.     
  497.     DC.B    64+5,'>LI'        ; ">link" ( 'addr -- link.addr )
  498.     DC.W    toname-theLink
  499. tolink:    SUBQ    #2,(PS)
  500.     RTS
  501.  
  502.     DC.B    3,'ID.'            ; "id." ( addr -- )
  503.     DC.W    tolink-theLink
  504. IDDot:    JSR    toname-base(BP)
  505.     MOVEA.L    DP,A0
  506.     MOVEQ.L    #5,D0
  507.     @0:    MOVE.L    #$C9C9C9C9,(A0)+    
  508.     DBRA    D0,@0
  509.     MOVE    (PS)+,D0
  510.     MOVE.L    0(BP,D0.W),(DP)
  511.     JSR    here-base(BP)
  512.     MOVE    (PS),-(PS)
  513.     JSR    cat-base(BP)
  514.     ANDI    #$1F,(PS)        ; look at 5 lsb's
  515.     ADDQ    #1,2(PS)
  516.     JSR    type-base(BP)
  517.     JSR    space-base(BP)
  518.     JMP    space-base(BP)
  519.     
  520.     DC.B    5,'WOR'            ; "words" ( -- ) list words
  521.     DC.W    iddot-theLink
  522. Words:    MOVE.L    D3,-(SP)        ; preserve register
  523.     MOVE    Dict,D3            ; start with the last word defined
  524.     @0:    MOVE    D3,-(PS)        ; push the name address
  525.     ADDQ    #6,(PS)            ; get the CFA
  526.     BSR.S    iddot            ; print the name
  527.     LEA    4(BP,D3.W),A0        ; get link addr in A0
  528.     MOVE    (A0),D3            ; put the next name addr into D3
  529.     TST.B    1(BP,D3.W)        ; Quit if name is 0
  530.     BEQ.S    @1            ; do next word if not=0
  531.     JSR    qterm-base(BP)
  532.         TST    (PS)+
  533.     BEQ.S    @0
  534.     @1:    MOVE.L    (SP)+,D3        ; restore register
  535.     RTS
  536.     
  537.     DC.B    6,'FOR'            ; "forget" ( -- ) forgets dictionary
  538.     DC.W    words-theLink
  539. Forget:    JSR    tick-base(BP)
  540.     MOVE    (PS)+,D0
  541.     LEA    -2(BP,D0.W),A0
  542.     MOVE    (A0),Dict
  543.     LEA    -6(BP,D0.W),DP
  544.     RTS
  545.  
  546.     DC.B    3,'PAD'            ; "pad" ( -- ) conversion pad
  547.     DC.W    forget-theLink
  548. Pad:    JSR    here-base(BP)
  549.     ADDI    #40,(PS)        ; pad is 40 bytes from HERE.
  550.     RTS
  551.     
  552.     DC.B    4,'HOL'            ; "hold" ( c -- ) place c at ...
  553.     DC.W    pad-theLink        ; ... addr in Held.
  554. Hold:    SUBQ    #1,held-base(BP)
  555.     MOVE    held-base(BP),-(PS)
  556.     JMP    cstore-base(BP)
  557.     
  558.     DC.B    4,'SIG'            ; "sign" ( sf dval -- dval )
  559.     DC.W    hold-theLink
  560. Sign:    JSR    rote-base(BP)
  561.     TST    (PS)+
  562.     BGE.S    @0
  563.     MOVE    #'-',-(PS)
  564.     BSR.S    hold
  565.     @0:    RTS
  566.  
  567.     DC.B    4,'DAB'            ; "dabs" ( dval -- |dval| )
  568.     DC.W    sign-theLink
  569. Dabs:    TST    (PS)
  570.     BGE.S    @0
  571.     JSR    dneg-base(BP)
  572.     @0:    RTS
  573.  
  574.     DC.B    2,'<#',0        ; "<#" ( -- )
  575.     DC.W    dabs-theLink
  576. LSharp:    BSR.S    pad
  577.     MOVE    (PS)+,held-base(BP)
  578.     MOVEA.L    DP,A0
  579.     MOVE    #9,D0
  580.     @0:    CLR.L    (A0)+
  581.     DBRA    D0,@0
  582.     MOVE    #30,-(PS)
  583.     BRA.S    hold
  584.  
  585.     DC.B    2,'#>'.0        ; "#>" ( dval -- addr len )
  586.     DC.W    lsharp-theLink
  587. SharpG:    ADDQ.L    #2,PS
  588.     MOVE    held-base(BP),(PS)
  589.     BSR.S    pad
  590.     MOVE    2(PS),-(PS)        ; over
  591.     ADDQ    #1,(PS)
  592.     JMP    minus-base(BP)
  593.     
  594.     DC.B    1,'#',0,0        ; "#" ( dval -- d/base )
  595.     DC.W    sharpg-theLink
  596. Sharp:    MOVE    NBase-base(BP),-(PS)
  597.     JSR    msmod-base(BP)
  598.     JSR    rote-base(BP)
  599.     CMPI    #9,(PS)            ; is top of stack < 9?
  600.     BLE.S    @0
  601.     ADDQ    #7,(PS)
  602.     @0:    ADDI    #48,(PS)
  603.     JMP    hold-base(BP)
  604.  
  605.     DC.B    2,'#S',0        ; "#s" ( dval -- 0 0 )
  606.     DC.W    sharp-theLink
  607. Sharps:    BSR.S    sharp
  608.     TST.L    (PS)
  609.     BNE.S    sharps
  610.     RTS
  611.  
  612.     DC.B    2,'D.',0        ; "d." ( dval -- )
  613.     DC.W    sharps-theLink
  614. DDot:    JSR    swapp-base(BP)
  615.     MOVE    2(PS),-(PS)
  616.     JSR    dabs-base(BP)
  617.     BSR.S    lsharp
  618.     BSR.S    sharps
  619.     JSR    sign-base(BP)
  620.     BSR.S    sharpg
  621.     JMP    type-base(BP)
  622.  
  623.     DC.B    2,'U.',0        ; "u." ( uval -- )
  624.     DC.W    ddot-theLink
  625. UDot:    CLR    -(PS)
  626.     BRA.S    ddot
  627.  
  628.     DC.B    3,'S>D'            ; "s>d" ( n -- d )
  629.     DC.W    udot-theLink
  630. SToD:    MOVE    (PS),-(PS)        ; dup
  631.     JMP    zerolt-base(BP)        ; 0<
  632.  
  633.     DC.B    1,'.',0,0        ; "." ( n -- )
  634.     DC.W    stod-theLink
  635. Dot:    BSR.S    stod
  636.     BRA.S    ddot
  637.  
  638.     DC.B    4,'(."'            ; "(.")" ( -- )
  639.     DC.W    dot-theLink        ;   runtime part of "
  640. pQuote:    MOVE.L    (RS),-(PS)        ; push the addr of the string
  641.     JSR    torel-base(BP)
  642.     ADDQ    #1,(PS)            ; skip the length byte
  643.     MOVE.L    (RS),A0
  644.     CLR.L    D0            ; clear the character count
  645.     MOVE.B    (A0),D0            ; get the length
  646.     MOVE    D0,-(PS)        ; push it
  647.     ADDQ    #2,D0
  648.     ANDI    #$FFFE,D0        ; be sure its even
  649.     ADD.L    D0,(RS)            ; skip over string upon return
  650.     JMP    type-base(BP)        ; type the string
  651.     
  652.     DC.B    130,'."',0        ; "."" ( -- ) compiler part of (.")
  653.     DC.W    pquote-theLink
  654. dotQ:    MOVE    #pQuote-base,-(PS)
  655.     JSR    compile-base(BP)    ; compile a call to (.")
  656.     JSR    here-base(BP)        ; ( -- addr )
  657.     MOVE    #'"',-(PS)        ; ( -- addr 34 )
  658.     JSR    word-base(BP)        ; ( -- addr )
  659.     JSR    cat-base(BP)        ; ( -- c )
  660.     ADDQ    #1,(PS)            ; ( -- c+1 )
  661.     JMP    allot-base(BP)        ; enclose the string in dictionary
  662.     
  663.     DC.B    1,'''',0,0        ; "'" ( -- rel.addr ) return the
  664.     DC.W    dotq-theLink        ;  cfa of the following word
  665. Tick:    JSR    Token-Base(BP)        ; get the next word
  666.     MOVE    Dict,-(PS)        ; push dict ptr to parmstk
  667.     JSR    Search-Base(BP)        ; lookup the current token
  668.     TST    (PS)+
  669.     BEQ    Whazat
  670.     RTS
  671.  
  672.     DC.B    128+9,'[CO'        ; "[compile]" ( -- )  compile
  673.     DC.W    tick-theLink        ;   the next immediate word
  674. bCompile:
  675.     JSR    tick-base(BP)        ; get the cfa of the next word
  676.     JMP    compile-base(BP)    ;  and compile a JSR to it
  677.     
  678.     DC.B    129,'(',0,0        ; "(" ( -- ) begin comment
  679.     DC.W    bcompile-theLink
  680. Comment    CMPI.B    #41,(IS)+        ; read in characters until ")"
  681.     BNE.S    Comment
  682.     RTS
  683.  
  684.     DC.B    5,'CMO'            ; "cmove" ( addr1 addr2 len -- )
  685.     DC.W    comment-theLink        ; from figFORTH, fixed 8/3/91
  686. CMove:    MOVE    (PS)+,D0        ; D0 = length
  687.     MOVE    (PS)+,D1
  688.     LEA    0(BP,D1.W),A1        ; A1 = addr2
  689.     MOVE    (PS)+,D1
  690.     LEA    0(BP,D1.W),A0        ; A0 = addr1
  691.     CMPA.L    A0,A1
  692.     BPL.S    @2
  693.  
  694.     BRA.S    @1            ;  addr1 > addr2
  695.     @0:    MOVE.B    (A0)+,(A1)+
  696.     @1:    DBRA    D0,@0
  697.     RTS
  698.  
  699.     @2:    ADDA    D0,A0            ;  addr1 ≤ addr2
  700.     ADDA    D0,A1
  701.     BRA.S    @4
  702.     @3:    MOVE.B    -(A0),-(A1)
  703.     @4:    DBRA    D0,@3
  704.     RTS
  705.     
  706.     DC.B    4,'FIL'            ; "fill" ( addr count char -- )
  707.     DC.W    cmove-theLink
  708. Fill:    MOVE    (PS)+,D0        ; character
  709.     MOVE    (PS)+,D1        ; count
  710.     SUBQ    #1,D1            ; decrement count
  711.     MOVE    (PS)+,A0        ; relative addr
  712.     LEA    0(BP,A0.W),A0        ; get absolute addr
  713.     @0:    MOVE.B    D0,0(A0,D1.W)        ; put char into addr + count
  714.         DBRA    D1,@0            ; decrement count & loop until 0
  715.     RTS
  716.     
  717.     DC.B    5,'COU'            ; "count" ( addr -- addr+1 length )
  718.     DC.W    fill-theLink
  719. Count:    CLR    D1
  720.     MOVE    (PS),D0
  721.     MOVE.B    0(BP,D0.W),D1
  722.     ADDQ    #1,(PS)
  723.     MOVE    D1,-(PS)
  724.     RTS
  725.     
  726.     DC.B    9,'-TR'            ; "-trailing"
  727.     DC.W    count-theLink        ;  ( addr count -- addr new.count )
  728. dtrail:    MOVE    (PS)+,D1            ; get the count
  729.     MOVE    (PS),D0            ; get the rel.addr
  730.     LEA    0(BP,D0.W),A0        ; get the abs.addr
  731.     @0:    CMPI.B    #$20,-1(A0,D1.W)    ; BEGIN  is char at addr+count $20
  732.     DBNE    D1,@0            ; NOT UNTIL
  733.     MOVE    D1,-(PS)        ; put new count on stack
  734.     RTS
  735.     
  736.     DC.B    64+1,'0',0,0        ; "0" ( -- 0 )
  737.     DC.W    dtrail-theLink
  738. Zero:    CLR    -(PS)
  739.     RTS
  740.     
  741.     DC.B    64+2,'1+',0        ; "1+" ( n -- n+1 )
  742.     DC.W    zero-theLink
  743. OnePl:    ADDQ    #1,(PS)
  744.     RTS
  745.  
  746.     DC.B    64+2,'1-',0        ; "1-" ( n -- n-1 )
  747.     DC.W    onepl-theLink
  748. OneMi:    SUBQ    #1,(PS)
  749.     RTS
  750.     
  751.     DC.B    64+2,'2+',0        ; "2+" ( n -- n+2 )
  752.     DC.W    onemi-theLink
  753. TwoPl:    ADDQ    #2,(PS)
  754.     RTS
  755.     
  756.     DC.B    64+2,'2*',0        ; "2*" ( n -- n*2 )
  757.     DC.W    twopl-theLink
  758. ToStar:    ASL    (PS)
  759.     RTS
  760.  
  761.     DC.B    64+2,'2/',0        ; "2/" ( n -- n/2 )
  762.     DC.W    tostar-theLink
  763. ToDiv:    ASR    (PS)
  764.     RTS
  765.     
  766.     DC.B    1,'@',0,0        ; "@" (at) ( addr16 -- n16 )
  767.     DC.W    todiv-theLink
  768. At:    MOVE    (PS),D0            ; DANGER: odd values crash this
  769.     MOVE    0(BP,D0.W),(PS)    
  770.     RTS
  771.  
  772.     DC.B    1,'!',0,0        ; "!" (store) ( n16 addr16 -- )
  773.     DC.W    at-theLink
  774. Store:    MOVE    (PS)+,D0        ; DANGER: odd values crash this
  775.     MOVE    (PS)+,0(BP,D0.W)
  776.     RTS
  777.  
  778.     DC.B    2,'C!',0        ; "c!" (sea-store)( n8 addr16 -- )
  779.     DC.W    store-theLink
  780. CStore:    MOVE    (PS)+,D0        ; get the rel.addr (odd OK)
  781.     ADDQ.L    #1,PS            ; align the stack
  782.     MOVE.B    (PS)+,0(BP,D0.W)    ; put data at the addr
  783.     RTS
  784.  
  785.     DC.B    2,'C@',0        ; "c@" (sea-at) ( addr16 -- n8 )
  786.     DC.W    cstore-theLink
  787. CAt:    MOVE    (PS),D0            ; get rel.addr (odd OK)
  788.     CLR    (PS)            ; clear the result
  789.     MOVE.B    0(BP,D0.W),1(PS)    ; stash the second byte
  790.     RTS
  791.  
  792.     DC.B    64+2,'L@',0        ; "l@" (el-at) ( daddr32 -- n16 )
  793.     DC.W    cat-theLink
  794. LAt:    MOVEA.L    (PS)+,A0        ; get the double number "real" addr
  795.     MOVE    (A0),-(PS)        ; fetch the contents
  796.     RTS
  797.  
  798.     DC.B    64+2,'L!',0        ; "l!" (el-store)( n16 daddr32 -- )
  799.     DC.W    lat-theLink
  800. LStore:    MOVEA.L    (PS)+,A0
  801.     MOVE    (PS)+,(A0)
  802.     RTS
  803.     
  804.     DC.B    64+3,'DL@'        ; "dl@" ( daddr32 -- d32 )
  805.     DC.W    lstore-theLink
  806. DLAt:    MOVEA.L    (PS),A0
  807.     MOVE.L    (A0),(PS)
  808.     RTS
  809.     
  810.     DC.B    64+3,'DL!'        ; "dl!" ( d32 daddr32 -- )
  811.     DC.W    dlat-theLink
  812. DLStor:    MOVE.L    (PS)+,A0
  813.     MOVE.L    (PS)+,(A0)
  814.     RTS
  815.  
  816.     DC.B    2,'+!',0        ; "+!" ( n16 addr16 -- )
  817.     DC.W    dlstor-theLink
  818. pstore:    MOVE    (PS)+,D0
  819.     MOVE    (PS)+,D1
  820.     ADD    D1,0(BP,D0.W)
  821.     RTS
  822.     
  823.     DC.B    64+4,'CBL'        ; "cblk" ( -- addr ) of fint
  824.     DC.W    pstore-theLink
  825. cBLK:    MOVE    #fint-base,-(PS)
  826.     RTS
  827.     
  828.     DC.B    64+6,'CST'        ; "cstate" ( -- addr ) of fcolon
  829.     DC.W    cblk-theLink
  830. cState:    MOVE    #fcolon-base,-(PS)
  831.     RTS
  832.  
  833.     DC.B    64+4,'BAS'        ; "base" ( -- addr )
  834.     DC.W    cstate-theLink        ;   variable for the numeric radix
  835. BaseA:    MOVE    #nbase-base,-(PS)
  836.     RTS
  837.  
  838.     DC.B    64+3,'TIB'        ; "tib" ( -- addr )
  839.     DC.W    basea-theLink        ;   variable for Terminal Input Buf.
  840. TIB:    MOVE    #termbuf-base,-(PS)
  841.     RTS
  842.  
  843.     DC.B    64+6,'LAT'        ; "latest" ( -- addr )
  844.     DC.W    tib-theLink        ;   variable for the last dict word
  845. Latest:    MOVE    Dict,-(PS)        ; push contents of the dict register
  846.     RTS
  847.  
  848.     DC.B    64+3,'R0@'        ; "r0@" ( -- dabs.addr )
  849.     DC.W    latest-theLink        ;   dabs.addr of r0
  850. R0at:    MOVE.L    rzero-base(BP),-(PS)
  851.     RTS
  852.  
  853.     DC.B    64+3,'RP@'        ; "rp@" ( -- dabs.addr )
  854.     DC.W    r0at-theLink        ;   current addr of the return stack
  855. RPat:    MOVE.L    RS,-(PS)
  856.     RTS
  857.  
  858.     DC.B    64+3,'S0@'        ; "s0@" ( -- dabs.addr )
  859.     DC.W    rpat-theLink        ;   dabs.addr of s0
  860. S0at:    MOVE.L    szero-base(BP),-(PS)
  861.     RTS
  862.  
  863.     DC.B    64+3,'SP@'        ; "sp@" ( -- dabs.addr )
  864.     DC.W    s0at-theLink        ; address of the current stack cell
  865. SPat:    MOVE.L    PS,-(PS)
  866.     RTS
  867.  
  868.     DC.B    4,'HER'            ; "here" ( -- addr )
  869.     DC.W    spat-theLink        ;   rel.addr of compile point
  870. here:     MOVE.L    DP,-(PS)
  871.     JMP    torel-base(BP)
  872.  
  873.     DC.B    3,'HEX'            ; "hex" ( -- )
  874.     DC.W    here-theLink
  875. hex:    MOVE    #$10,nbase-base(BP)
  876.     RTS
  877.  
  878.     DC.B    7,'DEC'            ; "decimal" ( -- )
  879.     DC.W    hex-theLink
  880. decimal    MOVE    #10,nbase-base(BP)
  881.     RTS
  882.     
  883.     DC.B    4,'?DU'            ; "?dup" ( n -- n n OR n [if n=0] )
  884.     DC.W    decimal-theLink
  885. qdup:    TST    (PS)
  886.     BNE.S    dup
  887.     RTS
  888.  
  889.     DC.B    64+3,'DUP'        ; "dup" ( n -- n n )
  890.     DC.W    qdup-thelink
  891. dup:    MOVE    (PS),-(PS)
  892.     RTS
  893.  
  894.     DC.B    64+4,'DRO'        ; "drop" ( n -- )
  895.     DC.W    dup-theLink
  896. drop:    ADDQ.L    #2,PS
  897.     RTS
  898.  
  899.     DC.B    4,'SWA'            ; "swap" ( n1 n2 -- n2 n1 )
  900.     DC.W    drop-theLink
  901. swapp:    MOVE.L    (PS)+,D0
  902.     SWAP    D0
  903.     MOVE.L    D0,-(PS)
  904.     RTS
  905.  
  906.     DC.B    64+4,'OVE'        ; "over" ( n1 n2 -- n1 n2 n1 )
  907.     DC.W    swapp-theLink
  908. over:    MOVE    2(PS),-(PS)
  909.     RTS
  910.  
  911.     DC.B    3,'ROT'            ; "rot" ( n1 n2 n3 -- n2 n3 n1 )
  912.     DC.W    over-theLink
  913. rote:    MOVE.L    (PS)+,D0
  914.     MOVE    (PS)+,D1
  915.     MOVE.L    D0,-(PS)
  916.     MOVE    D1,-(PS)
  917.     RTS
  918.  
  919.     DC.B    64+4,'2DU'        ; "2dup" ( n1 n2 -- n1 n2 n1 n2 )
  920.     DC.W    rote-theLink
  921. todup:    MOVE.L    (PS),-(PS)
  922.     RTS
  923.  
  924.     DC.B    5,'2SW'            ; "2swap"
  925.     DC.W    todup-theLink        ;  ( n1 n2 n3 n4 -- n3 n4 n1 n2 )
  926. toswap:    MOVE.L    (PS)+,D0
  927.     MOVE.L    (PS)+,D1
  928.     MOVE.L    D0,-(PS)
  929.     MOVE.L    D1,-(PS)
  930.     RTS
  931.     
  932.     DC.B    4,'>AB'            ; ">abs" (to-abs)
  933.     DC.W    toswap-theLink        ; ( addr16 -- daddr32 )
  934. toAbs:    CLR.L    D0
  935.     MOVE    (PS)+,D0        ; pop rel addr
  936.     LEA    0(BP,D0.W),A0        ; calc as offset to base ...
  937.     MOVE.L    A0,-(PS)        ; ...  and push
  938.     RTS
  939.  
  940.     DC.B    64+2,'>R',0        ; ">r" ( n -- ) rstack: ( -- n16 )
  941.     DC.W    toabs-theLink
  942. toR:    MOVE    (PS)+,-(RS)
  943.     RTS
  944.  
  945.     DC.B    64+2,'R>',0        ; "r>" ( -- n ) rstack: ( n16 -- )
  946.     DC.W    tor-theLink
  947. Rfrom:    MOVE    (RS)+,-(PS)
  948.     RTS
  949.  
  950.     DC.B    64+1,'R',0,0        ; "r" ( -- n ) rs: ( n16 -- n16 )
  951.     DC.W    rfrom-theLink
  952. Are:    MOVE    (RS),-(PS)
  953.     RTS
  954.  
  955.     DC.B    4,'EXI'            ; "exit" ( -- ) drops return address
  956.     DC.W    are-theLink
  957. Exit:    ADDQ.L    #4,RS
  958.     RTS
  959.     
  960.     DC.B    64+1,'+',0,0        ; "+" ( n1 n2 -- n1+n2 )
  961.     DC.W    exit-theLink
  962. plus:    MOVE    (PS)+,D0
  963.     ADD    D0,(PS)
  964.     RTS
  965.  
  966.     DC.B    64+6,'NEG'        ; "negate" ( n -- -n )
  967.     DC.W    plus-theLink
  968. negate:    NEG    (PS)
  969.     RTS
  970.  
  971.     DC.B    1,'-',0,0        ; "-" ( n1 n2 -- n1-n2 )
  972.     DC.W    negate-theLink
  973. minus:    NEG    (PS)
  974.     BRA.S    plus
  975.  
  976.     DC.B    1,'*',0,0        ; "*" ( n1 n2 -- n1*n2 )
  977.     DC.W    minus-theLink
  978. times:    MOVE    (PS)+,D0
  979.     MULS    (PS)+,D0
  980.     MOVE    D0,-(PS)
  981.     RTS
  982.  
  983.     DC.B    4,'/MO'            ; "/mod ( n1 n2 -- rem quot )
  984.     DC.W    times-theLink
  985. Smod:    MOVE    (PS)+,D0
  986.     BNE.S    @0
  987.     BRA.S    sfail
  988.     @0:    MOVE    (PS)+,D1
  989.     EXT.L    D1
  990.     DIVS    D0,D1
  991.     SWAP    D1
  992.     MOVE.L    D1,-(PS)
  993.     RTS
  994.  
  995.     DC.B    1,'/',0,0        ; "/" ( n1 n2 -- quotient )
  996.     DC.W    smod-theLink
  997. Slash:    JSR    smod-base(BP)
  998.     JSR    swapp-base(BP)
  999.     ADDQ.L    #2,PS
  1000.     RTS
  1001.  
  1002.     DC.B    3,'MOD'            ; "mod"    ( n1 n2 -- remainder )
  1003.     DC.W    slash-theLink
  1004. mod:    JSR    smod-base(BP)
  1005.     ADDQ.L    #2,PS
  1006.     RTS
  1007.  
  1008.     DC.B    2,'*/',0        ; "*/" ( n1 n2 n3 -- n1*n2/n3 )
  1009.     DC.W    mod-theLink
  1010. SSlash:    MOVE    (PS)+,D1
  1011.     BNE.S    sok
  1012.     ADDQ.L    #2,PS
  1013.  sfail:    MOVE    #-1,(PS)
  1014.     RTS
  1015.    sok:    MOVE    (PS)+,D0
  1016.     MULS    (PS),D0
  1017.     DIVS    D1,D0
  1018.     MOVE    D0,(PS)
  1019.     RTS
  1020.  
  1021.     DC.B    2,'U*',0        ; "u*" ( n1 n2 -- d32 )
  1022.     DC.W    sslash-theLink
  1023. UStar:    MOVE    (PS)+,D0
  1024.     MULU    (PS)+,D0
  1025.     MOVE.L    D0,-(PS)
  1026.     RTS
  1027.     
  1028.     DC.B    5,'M/M'            ; "m/mod" from King&Knight
  1029.     DC.W    ustar-theLink        ; ( num32 denom16 -- rem16 quot32 )
  1030. MSMod:    TST    (PS)            ; test for div by zero
  1031.     BNE.S    @0
  1032.     ADDQ.L    #4,PS
  1033.     BRA.S    sfail
  1034.     @0:    MOVE.L    D2,-(SP)        ; save D2
  1035.     MOVEQ    #0,D2            ; clear it
  1036.     MOVE    (PS)+,D2        ; pop denom into D2.W
  1037.     MOVE.L    (PS)+,D1        ; pop num into D1.L
  1038.     MOVE    D1,-(SP)        ; hold num.l on rstack
  1039.     CLR    D1
  1040.     SWAP    D1
  1041.     DIVU    D2,D1
  1042.     MOVE    D1,D0
  1043.     MOVE    (SP)+,D1
  1044.     DIVU    D2,D1
  1045.     SWAP    D1
  1046.     MOVE    D1,-(PS)        ; push remainder
  1047.     MOVE    D0,D1
  1048.     SWAP    D1
  1049.     MOVE.L    D1,-(PS)        ; push quotient
  1050.     MOVE.L    (SP)+,D2        ; restore register
  1051.     RTS
  1052.     
  1053.     DC.B    64+7,'DNE'        ; "dnegate" ( d32 -- -d32 )
  1054.     DC.W    msmod-theLink
  1055. DNeg:    NEG.L    (PS)
  1056.     RTS
  1057.     
  1058.     DC.B    64+2,'D+',0        ; "d+" ( d1 d2 -- d1+d2 )
  1059.     DC.W    dneg-theLink
  1060. DPlus:    MOVE.L    (PS)+,D0
  1061.     ADD.L    D0,(PS)
  1062.     RTS
  1063.     
  1064.     DC.B    128+2,'IF',0        ; "if" ( flag -- ) at runtime
  1065.     DC.W    dplus-theLink        ;      ( -- addr ) at compile time
  1066. pIf:    MOVE.L    #$4A5E6700,(DP)+    ; compile tst (ps)+  beq ...
  1067.     JSR    here-base(BP)        ; leave address on stack
  1068.     ADDQ.L    #2,DP            ; make room for offset
  1069.     RTS
  1070.     
  1071.     DC.B    128+5,'WHI'        ; "while" ( flag -- ) at runtime
  1072.     DC.W    pif-theLink        ;    ( -- addr ) at compile time
  1073. pWhile:    BRA.S    pIf
  1074.     
  1075.     DC.B    128+4,'ELS'        ; "else" ( -- ) at runtime
  1076.     DC.W    pwhile-theLink        ; ( addr -- addr ) at compile time
  1077. pElse:    MOVE    #$6000,(DP)+
  1078.     JSR    here-base(BP)
  1079.     ADDQ.L    #2,DP
  1080.     JSR    swapp-base(BP)
  1081.     BRA.S    pthen
  1082.  
  1083.     DC.B    128+4,'THE'        ; "then" ( -- ) at runtime
  1084.     DC.W    pelse-theLink        ;   ( addr -- ) at compile time
  1085. pThen:    JSR    here-base(BP)        ; : THEN  HERE OVER - SWAP ! ;
  1086.     MOVE    2(PS),-(PS)        ; over
  1087.     JSR    minus-base(BP)
  1088.     JSR    swapp-base(BP)
  1089.     JMP    store-base(BP)
  1090.  
  1091.     DC.B    128+6,'REP'        ; "repeat" ( -- ) at runtime
  1092.     DC.W    pthen-theLink        ; ( b.addr w.addr -- ) at c.time
  1093. pRepet:    MOVE    #$6000,(DP)+        ; compile bra ...
  1094.     JSR    swapp-base(BP)
  1095.     BSR.S    back
  1096.     BRA.S    pThen            ; HERE OVER - SWAP ! ;
  1097.  
  1098.     DC.B    128+5,'BEG'        ; "begin" ( -- ) at runtime
  1099.     DC.W    prepet-theLink        ;    ( -- addr ) at compile time
  1100. pBegin:    JMP    here-base(BP)
  1101.  
  1102.     DC.B    128+5,'UNT'        ; "until" ( flag -- ) at runtime
  1103.     DC.W    pbegin-theLink        ;      ( addr -- ) at compile time
  1104. pUntil    MOVE.L    #$4A5E6700,(DP)+    ; compile tst (ps)+  beq ...
  1105.     BRA.S    back
  1106.     
  1107.     DC.B    128+5,'AGA'        ; "again" ( -- ) at runtime
  1108.     DC.W    puntil-theLink        ;    ( addr -- ) at compile time
  1109. pAgain:    MOVE    #$6000,(DP)+        ; compile bra ...
  1110.     BRA.S    back
  1111.  
  1112.     DC.B    4,'BAC'            ; "back" ( addr -- )
  1113.     DC.W    pagain-theLink        ;  compile negative displacement
  1114. back:    JSR    here-base(BP)
  1115.     JSR    minus-base(BP)
  1116.     MOVE    (PS),D0            ; get the target addr into d0
  1117.     BGE.S    @0
  1118.     NEG    D0            ; make it positive
  1119.     @0:    ANDI    #$FF00,D0        ; if > 1 byte
  1120.     BEQ.S    @1
  1121.     JMP    comma-base(BP)        ; then comma it as a long branch
  1122.     @1:    MOVE.B    1(PS),-1(DP)        ; else make it a short branch
  1123.     JMP    drop-base(BP)
  1124.  
  1125.     DC.B    128+2,'DO',0        ; "do" ( -- addr ) at compile time
  1126.     DC.W    back-theLink        ;  ( limit index -- ) at runtime
  1127. do:    MOVE    #$2F1E,(DP)+        ; • move.l (ps)+,-(ps)
  1128.     JMP    here-base(BP)        ; leave this address for loop
  1129.     
  1130.     DC.B    128+4,'LOO'        ; "loop" ( -- ) at runtime
  1131.     DC.W    do-theLink        ;   ( addr -- ) at compile time
  1132. Loop:    MOVE    #$5257,(DP)+        ;  • addq #1,(rs)  (increment ix)
  1133.   pl:    MOVE    #$3017,(DP)+        ;  • move (rs),d0  (get ix)
  1134.     MOVE.L    #$B06F0002,(DP)+    ;  • cmp  2(rs),d0 (check lim)
  1135.     MOVE    #$6B00,(DP)+        ;  • bmi  ...      (loop if ix<lim)
  1136.     BSR.S    back            ; comma in the displacement to 'do'
  1137.     MOVE    #$588F,(DP)+        ;  • addq.l #4,rs    (drop ix&lim)
  1138.     RTS
  1139.     
  1140.     DC.B    128+5,'+LO'        ; "+loop" ( n -- ) at runtime
  1141.     DC.W    loop-theLink        ;   ( addr -- ) at compile time
  1142. pLoop:    MOVE.L    #$301ED157,(DP)+    ;  • move (ps)+,d0
  1143.     BRA.S    pl            ;  • add  d0,(rs)
  1144.     
  1145.     DC.B    5,'LEA'            ; "leave" ( -- )
  1146.     DC.W    ploop-theLink        ;  set the index to the limit
  1147. Leave:    MOVE    6(RS),4(RS)
  1148.     RTS
  1149.  
  1150.     DC.B    2,'0<',0        ; "0<" ( n -- flag )
  1151.     DC.W    leave-theLink
  1152. ZeroLT:    TST    (PS)
  1153.     BLT.S    true
  1154.  false:    CLR    (PS)
  1155.     RTS
  1156.  true:    MOVE    #-1,(PS)
  1157.     RTS
  1158.  
  1159.     DC.B    2,'0>',0        ; "0>" ( n -- flag )
  1160.     DC.W    zerolt-theLink
  1161. ZeroGT:    NEG    (PS)
  1162.     BRA.S    zerolt
  1163.  
  1164.     DC.B    2,'0=',0        ; "0=" ( n -- flag )
  1165.     DC.W    zerogt-theLink
  1166. ZeroEQ:    TST    (PS)
  1167.     BEQ.S    true
  1168.     BRA.S    false
  1169.  
  1170.     DC.B    1,'=',0,0        ; "=" ( n1 n2 -- flag )
  1171.     DC.W    zeroeq-theLink
  1172. equal:    JSR    minus-base(BP)
  1173.     BRA.S    zeroeq
  1174.  
  1175.     DC.B    1,'<',0,0        ; "<" ( n1 n2 -- flag )
  1176.     DC.W    equal-theLink
  1177. lesst:    JSR    minus-base(BP)
  1178.     BRA.S    zerolt
  1179.  
  1180.     DC.B    1,'>',0,0        ; ">" ( n1 n2 -- flag )
  1181.     DC.W    lesst-theLink
  1182. moret:    JSR    minus-base(BP)
  1183.     BRA.S    zerogt
  1184.  
  1185.     DC.B    64+3,'AND'            ; "and"    ( n1 n2 -- n1(and)n2 )
  1186.     DC.W    moret-theLink
  1187. andd:    MOVE    (PS)+,D0
  1188.     AND    D0,(PS)
  1189.     RTS
  1190.  
  1191.     DC.B    64+2,'OR',0        ; "or" ( n1 n2 -- n1(or)n2 )
  1192.     DC.W    andd-theLink
  1193. orr:    MOVE    (PS)+,D0
  1194.     OR    D0,(PS)
  1195.     RTS
  1196.     
  1197.     DC.B    64+3,'XOR'            ; "xor" ( n1 n2 -- n1(xor)n2 )
  1198.     DC.W    orr-theLink
  1199. xor:    MOVE    (PS)+,D0
  1200.     EOR    D0,(PS)
  1201.     RTS
  1202.  
  1203.     DC.B    3,'ABS'            ; "abs"    ( n1 -- abs(n1) )
  1204.     DC.W    xor-theLink
  1205. abs:    TST    (PS)
  1206.     BGE.S    @0
  1207.     NEG    (PS)
  1208.     @0:    RTS
  1209.  
  1210.         DC.B    3,'MIN'            ; "min" ( n1 n2 -- n(min) )
  1211.     DC.W    abs-theLink
  1212. min:    MOVE    (PS)+,D0
  1213.     CMP    (PS),D0
  1214.     BLT.S    pd0
  1215.     RTS
  1216.    pd0:    MOVE    D0,(PS)
  1217.     RTS
  1218.  
  1219.         DC.B    3,'MAX'            ; "max" ( n1 n2 -- n(max) )
  1220.     DC.W    min-theLink
  1221. max:    MOVE    (PS)+,D0
  1222.     CMP    (PS),D0
  1223.     BGE.S    pd0
  1224.     RTS
  1225.  
  1226.     DC.B    130,',$',0        ; ",$" ( -- )
  1227.     DC.W    max-theLink        ; compile a hex number from input
  1228. CommaH:    MOVE    NBase-base(BP),-(RS)
  1229.     MOVE    #$10,nbase-base(BP)
  1230.     JSR    token-base(BP)
  1231.     JSR    here-base(BP)
  1232.     JSR    number-base(BP)
  1233.     MOVE    (RS)+,nbase-base(BP)
  1234.     TST    (PS)+
  1235.     BEQ    whazat
  1236.     JMP    comma-base(BP)
  1237.     
  1238.     DC.B    2,'2@',0        ; "2@" ( addr -- d )
  1239.     DC.W    commah-theLink        ; 32 bit fetch
  1240. TwoAt:    MOVE    (PS)+,D0
  1241.     LEA    0(BP,D0.W),A0
  1242.     MOVE.L    (A0),-(PS)
  1243.     RTS
  1244.  
  1245.     DC.B    2,'2!',0        ; "2!" ( d addr -- )
  1246.     DC.W    twoat-theLink        ; 32 bit store
  1247. TwoStore:
  1248.     MOVE    (PS)+,D0
  1249.     LEA    0(BP,D0.W),A0
  1250.     MOVE.L    (PS)+,(A0)
  1251.     RTS
  1252.  
  1253.     DC.B    9,'2CO'            ; "2constant"
  1254.     DC.W    twostore-theLink    ; defining: ( d -- )
  1255. TwoCon:    JSR    token-base(BP)        ; executing: ( -- d )
  1256.     JSR    header-base(BP)
  1257.     JSR    dlit-base(BP)
  1258.     MOVE    #$4E75,(DP)+
  1259.     RTS
  1260.  
  1261.     DC.B    9,'2VA'            ; "2variable"
  1262.     DC.W    twocon-theLink        ; defining: ( -- )
  1263. TwoVar:    JSR    variable-base(BP)    ; executing: ( -- addr )
  1264.     ADDQ.L    #2,DP
  1265.     RTS
  1266.  
  1267.     DC.B    64+3,'2>R'        ; "2>r" ( d -- ) rstack: ( -- d )
  1268.     DC.W    twovar-theLink
  1269. TwoToR:    MOVE.L    (PS)+,-(RS)
  1270.     RTS
  1271.  
  1272.     DC.B    64+3,'2R>'        ; "2r>" ( -- d ) rstack: ( d -- )
  1273.     DC.W    twotor-theLink
  1274. TwoRFrom:
  1275.     MOVE.L    (RS)+,-(PS)
  1276.     RTS
  1277.     
  1278.     DC.B    3,'A>R'            ; "a>r" ( addr -- )
  1279.     DC.W    tworfrom-theLink    ;   rstack: ( -- dabs.addr )
  1280. AToR:    JSR    toabs-base(BP)
  1281.     MOVE.L    (SP)+,A0
  1282.     MOVE.L    (PS)+,-(SP)
  1283.     JMP    (A0)
  1284.  
  1285.     DC.B    64+5,'2OV'        ; "2over" ( d1 d2 -- d1 d2 d1 )
  1286.     DC.W    ator-theLink
  1287. TwoOver:
  1288.     MOVE.L    4(PS),-(PS)
  1289.     RTS
  1290.  
  1291.     DC.B    4,'2RO'            ; "2rot" ( d1 d2 d3 -- d2 d3 d1 )
  1292.     DC.W    twoover-theLink
  1293. TwoRot:    MOVE.L    (PS)+,D0
  1294.     MOVE.L    (PS)+,D1
  1295.     MOVE.L    (PS),A0
  1296.     MOVE.L    D1,(PS)
  1297.     MOVE.L    D0,-(PS)
  1298.     MOVE.L    A0,-(PS)
  1299.     RTS
  1300.  
  1301.     DC.B    64+5,'2DR'        ; "2drop" ( d -- )
  1302.     DC.W    tworot-theLink
  1303. TwoDrop:
  1304.     ADDQ.L    #4,PS
  1305.     RTS
  1306.  
  1307.     DC.B    4,'@PE'            ; "@pen" ( -- h v )
  1308.     DC.W    twodrop-theLink
  1309. AtPen:    PEA    (DP)
  1310.     _GetPen
  1311.     MOVE.L    (DP),-(PS)
  1312.     RTS
  1313.  
  1314.     DC.B    64+4,'!PE'        ; "!pen" ( h v -- )
  1315.     DC.W    atpen-theLink
  1316. SetPen:    MOVE.L    (PS)+,-(SP)
  1317.     _MoveTo
  1318.     RTS
  1319.  
  1320.     DC.B    64+3,'-TO'        ; "-to" ( h v -- )
  1321.     DC.W    setpen-theLink
  1322. LineTo:    MOVE.L    (PS)+,-(SP)
  1323.     _LineTo
  1324.     RTS
  1325.  
  1326.     DC.B    64+5,'PMO'        ; "pmode" ( mode -- )
  1327.     DC.W    lineto-theLink
  1328. PMode:    MOVE    (PS)+,-(SP)
  1329.     _PenMode
  1330.     RTS
  1331.  
  1332.     DC.B    6,'@MO'            ; "@mouse" ( -- h v )
  1333.     DC.W    pmode-theLink
  1334. AtMouse:
  1335.     SUBQ.L    #4,PS
  1336.     PEA    (PS)
  1337.     _GetMouse
  1338.     RTS
  1339.  
  1340.     DC.B    7,'?BU'            ; "?button" ( -- flag )
  1341.     DC.W    atmouse-theLink
  1342. QButton:
  1343.     CLR    -(SP)
  1344.     _Button
  1345.     MOVE    (SP)+,-(PS)
  1346.     BEQ.S    @0
  1347.     SUBI    #257,(PS)
  1348.     @0:    RTS